Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/demostu2/doom2.pas

Pascal/Delphi Source File | 1994-12-15 | 16.0 KB | 660 lines

PROGRAM doom2;
{
  DOOM engine, version 0.00002
  - by Bjarke Viksφe
  nov 1994

  Second version of the DOOM :) Well, it turned out to be a pretty crude
  one. There's still an annoying bug in the walls which makes them
  flicker... Know what the bug is, just don't care to fix it.
  Only advise to you: play the real thing instead!
  Walls are implemented by extending the ray-casting scheme. Anyway,
  this is just an example showing you that nice wolfy effects can be made
  in less than 700 lines! Completely textured and it can even handle
  ROUND walls !!! Resolution is 160x160 (which is sadly low).
  Ok, perhaps calling it DOOM was aiming a bit high :)
}

{$A+,B-,G+,E+,I+,N-,X+}
{$IFDEF DPMI}
{$C FIXED PRELOAD PERMANENT}
{$ENDIF}

USES
    DEMOINIT,MOUSE,ILBM256,PICTURE;

{{$DEFINE DEBUG}

TYPE
    pBunk = ^BunkArray;
    BunkArray = ARRAY[0..254, 0..255] of byte;
    pIntegerArray = ^IntegerArray;
    IntegerArray = ARRAY[0..32765] of integer;

CONST
    LINES = 70; {how many lines shall we paint}
    VIEWPOS = 16; {this will ajust the viewer's eyesight}
    STEPBACK = 10; {rotate origo}
    TILT = 31780; {tilt floor how much?}

    FILLED_TABLE = $7F00; {offset into map segment where tables are placed}
    WALL_TABLE = 18000*2;

VAR
    buffer : pScreen;
    map, tiles : pBunk;
    LineTable : array[1..3] of pIntegerArray;
    xpos,ypos, angle : word;
    CoordPtr : array[0..255] of pointer;
    SinusTable  : array[0..639] of integer;

VAR    {DOOM draw private variables}
    tablepos : word;
    height : word;
CONST
    {table that describes how the colours fades away...}
    colourtable : array[1..LINES+1] of byte =
        (224,224,224,224,224,
        192,192,192,192,192,192,
        160,160,160,160,160,160,160,
        128,128,128,128,128,128,128,128,
        96,96,96,96,96,96,96,96,
        64,64,64,64,64,64,64,64,64,
        32,32,32,32,32,32,32,32,32,32,
        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);


(*------------------------------------------------*)

procedure SetupSinus;
var
    i : integer;
    v, vadd : real;
begin
    v:=0.0;
    vadd:=(2.0*pi/512.0);
    for i:=0 to 639 do begin
        SinusTable[i]:=round(sin(v)*32767);
        v:=v+vadd;
    end;
end;

procedure SetColours;
{Setup ugly colours}
var
    i,j,k,fac : integer;
begin
    {calc 8 shades of our 32 colours}
    k:=1;
    fac:=256;
    for i:=1 to 8 do begin
        for j:=1 to (32*3) do begin
            CMAP[k]:=(CMAP[j] * fac) DIV 256;
            inc(k);
        end;
        dec(fac,31);
    end;
    SetCMAP;
end;


procedure CreateMap;
var
    charmap : array[#0..#128] of byte;
{Create map.
 Characters in strings are indexes to tiles! 'a' is tile #0, 'b' is #1...}
 procedure Strip(ypos : integer; st : string);
 var j : integer;
 begin
        for j:=1 to length(st) do st[j]:=char(charmap[st[j]]);
        Move(st[1],map^[ypos,1],length(st));
 end;
var
    c : char;
begin
    GetMem(map,65535);
    if (Ofs(map^)<>0) then halt;
    FillChar(map^,65535,#0);

    charmap[' ']:=0;
    for c:='a' to 'z' do charmap[c]:=ord(c)-ord('a'); {floor textures}
    for c:='1' to '9' do charmap[c]:=ord(c)-ord('1')+24; {wall textures}
    charmap['*']:=128+40; {marks square walls - walltexture taken from floor}
    charmap['@']:=128+41; {marks round pillar}
    charmap['(']:=128+42; {marks round wall}
    charmap[')']:=128+44; {marks round wall}
    charmap['=']:=128+46; {marks left/right square wall}
    charmap[']']:=128+47; {marks up/down square wall}

    {floor}
    Strip( 20,'    1111111111111111111111111111111111111                        ');
    Strip( 21,'    1dcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd4   77777                ');
    Strip( 22,'    1cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdc4   7ili7                ');
    Strip( 23,'    1dcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdgg4   7kjm7                ');
    Strip( 24,'    1cdc11111111111111111111111111111ggg4   7ini7                ');
    Strip( 25,'    1dcd1              666666555555 4ggg4   7iii7                ');
    Strip( 26,'    1cdc1              6gigigigigi554ggg45555iii5                ');
    Strip( 27,'    1dcd1              666666gigigigigggiiiiliii5                ');
    Strip( 28,'    1cdc1                  655g1gigiggggiiikjmii5                ');
    Strip( 29,'    1dcd1            33333  655gigigigggiiiiniii5                ');
    Strip( 30,'    1cdc1            3fff3  665555554ggg455555555                ');
    Strip( 31,'    1dcd1            3fff3          44444                        ');
    Strip( 32,'    1cdc12222222222222fff2222                                    ');
    Strip( 33,'    1dcoffffffffffffffffffff2                                    ');
    Strip( 34,'    1cofffffffffffffffffffff2                                    ');
    Strip( 35,'    1offfffffffffffffffffff22                                    ');
    Strip( 36,'    122222222222222222222222                                     ');
    {ceiling}
    Strip(148,'    *===================================*                        ');
    Strip(149,'    ]bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb]   *===*                ');
    Strip(150,'    ]bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb]   ]eee]                ');
    Strip(151,'    ]bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb]   ]eee]                ');
    Strip(152,'    ]bbb(===========================*bbb]   ]eee]                ');
    Strip(153,'    ]bbb]              *==========* ]bbb]   ]eee]                ');
    Strip(154,'    ]bbb]              ]eeeeeeeeee*=*bbb*===*eee]                ');
    Strip(155,'    ]bbb]              *====)iiiieeeebbbeeeeeeee]                ');
    Strip(156,'    ]bbb]                  **)i@ieeeebbbeeeeeeee]                ');
    Strip(157,'    ]bbb]            *===*  **)iieeeebbbeeeeeeee]                ');
    Strip(158,'    ]bbb]            ]eee]  **======*bbb*=======*                ');
    Strip(159,'    ]bbb]            ]eee]          *===*                        ');
    Strip(160,'    ]bbb*============*eee*==*                                    ');
    Strip(161,'    ]bbpeeeeeeeeeeeeeeeeeeee]                                    ');
    Strip(162,'    ]bpeeeeeeeeeeeeeeeeeeeee]                                    ');
    Strip(163,'    ]peeeeeeeeeeeeeeeeeeeee**                                    ');
    Strip(164,'    *======================*                                     ');
end;

procedure CreateTiles;
{Build the tiles. Load .lbm graphics picture}
var
    i,j,k : word;
begin
    GetMem(tiles,65535);
    if (Ofs(tiles^)<>0) then halt;
    FillChar(tiles^,65535,#0);

    LoadPix(pScreen(tiles),'doomgfx1.lbm');
    {picture is 320x200. Need to convert it to 256x200}
    j:=0; k:=0;
    for i:=1 to 200 do begin
        Move(pscreen(tiles)^[j],pScreen(tiles)^[k],256);
        inc(j,320);
        inc(k,256);
    end;
end;

procedure PrecalcWallRuns;
{Precalc wall-texture heigth data}
var
    a : pIntegerArray;
    i,j,ysize : word;
begin
    a:=pIntegerArray(map);
    i:=WALL_TABLE DIV 2;
    ysize:=161;
    for j:=1 to LINES do begin
        a^[i]:=ysize;
        a^[i+1]:=(64 SHL 8) DIV ysize;
        inc(i,2);
        dec(ysize,2);
    end;
end;

procedure PrecalcLines;
{Precalc rotated floor-lines data}
var
    q,p,i, x1,y1,x2,y2 : integer;
    z,sin1,cos1 : integer;
    pos,angle : word;
    cx,cy : longint;
    w : longint;
begin
    for i:=1 to 3 do GetMem(LineTable[i],65535);

    p:=1; w:=1 SHL 17;
    pos:=0;
    angle:=0;
    for q:=0 to 255 do begin
        CoordPtr[q]:=@LineTable[p]^[pos];

        z:=31100;
        sin1:=SinusTable[angle];
        cos1:=SinusTable[angle+128];
        for i:=1 to LINES do begin
            x1:=LongDiv(-VIEWPOS*65536*4,z); {calc first coord}
            y1:=LongDiv((i+STEPBACK)*longint(TILT)*4,z);
            cx := (LongMul(x1,cos1) - LongMul(y1,sin1)) DIV w; {rotate it}
            cy := (LongMul(x1,sin1) + LongMul(y1,cos1)) DIV w;
            x1:=cx;
            y1:=cy;
            LineTable[p]^[pos]:=x1;
            LineTable[p]^[pos+1]:=y1;

            x2:=LongDiv(VIEWPOS*65535*4,z); {calc second coord}
            y2:=LongDiv((i+STEPBACK)*longint(TILT)*4,z);
            cx := (LongMul(x2,cos1) - LongMul(y2,sin1)) DIV w; {rotate it}
            cy := (LongMul(x2,sin1) + LongMul(y2,cos1)) DIV w;
            x2:=cx;
            y2:=cy;
            LineTable[p]^[pos+2]:=(longint(x2-x1) SHL 11) DIV 160;
            LineTable[p]^[pos+3]:=(longint(y2-y1) SHL 11) DIV 160;
            inc(pos,4);

            dec(z,330);
        end;

        {Check if next set of coords should be placed in other buffer, since
         they cannot all fit into one 64Kb segment!!!}
        if ((pos*2 + (LINES*8)) > 65200) then begin
            inc(p);
            pos:=0;
        end;
        inc(angle,1); {calc next angle}
    end;
end;



procedure InitDemo;
var
    i : integer;
begin
    ClearWholeScreen;
    SetupSinus;

    GetMem(buffer,65534);
    FillChar(buffer^,65534,0);

    CreateMap;
    CreateTiles;
    SetColours;
    PrecalcWallRuns;
    PrecalcLines;

    xpos:=250; ypos:=800;        {starting position}
    angle:=0;                        {start view angle}
end;

procedure UninitDemo;
var
    i : integer;
begin
    FreeMem(buffer,65534);
    FreeMem(map,65535);
    FreeMem(tiles,65535);
    for i:=1 to 3 do FreeMem(LineTable[i],65535);
end;


(*------------------------------------------------*)

procedure MoveHero;
var
    x,y, oldx,oldy, sin1,cos1 : integer;
    cx,cy : longint;
begin
    {Determine new rotation angle}
    ReadMouseMotionCounters(x,y);
    angle:=(angle - x) AND 511;

    {is hero moving forward?}
    if (LeftButton) then begin
        oldx:=xpos;
        oldy:=ypos;
        sin1:=SinusTable[angle];
        cos1:=SinusTable[angle+128];
        x:=0;  {this is the moving speed}
        y:=(5*(retraces+1)) DIV 2;
        cx := (longmul(x,cos1) - longmul(y,sin1)) DIV 32768;
        cy := (longmul(x,sin1) + longmul(y,cos1)) DIV 32768;
        inc(xpos,cx);
        inc(ypos,cy);
        {has hero bumped into a wall?}
        if (map^[(ypos SHR 5)+128, xpos SHR 5] >= 128) then begin
            xpos:=oldx; ypos:=oldy;
        end;
    end;
end;

(*------------------------------------------------*)

procedure DrawDoom(x,y, angle : integer; Coords : pointer); assembler;
var
    xadd,yadd,
    mappos,walltablepos : word;
    mapxadd,mapyadd : integer;
    counts : word;
    ceilingtile, flooradd : word;
    colouradd : byte;
asm
    push    ds

    {clear "filled-out" lookup-table! Keeps track of blocked vert. lines}
    mov    es,WORD PTR [map+2]
    mov    di,FILLED_TABLE-2
    mov    cx,(160/4)+1
    DB LONG; xor ax,ax
    cld
    DB LONG; rep stosw

    {clear middle of screen}
    mov    es,WORD PTR [buffer+2]
    mov    di,70*320
    mov    cx,(25*320)/4
    DB LONG; rep stosw
    mov    di,0    {ES:DI points at screen}

    mov    [flooradd],(160*320)
    mov    [colouradd],0
    mov    [walltablepos],WALL_TABLE

    mov    ax,WORD PTR [map+2]
    {mov fs,ax} DB $8E,$E0
    mov    ax,WORD PTR [Coords+2]
    {mov gs,ax} DB $8E,$E8
    mov    ax,WORD PTR [Coords]
    mov    [tablepos],ax

    mov    [height],LINES

{=---- This is the loop for each horizontal line ----=}

@y_run:

    mov    si,[tablepos]

    DB GS; mov    ax,[si+4]                    {setup raycasting run}
    cmp    [angle],256
    jb        @anglelow1
    neg    ax
@anglelow1:
    mov    [xadd],ax
    mov    [mapxadd],1
    or        ax,ax
    jns    @mapxup
    mov    [mapxadd],-1
@mapxup:
    DB GS; mov    ax,[si+6]
    cmp    [angle],256
    jb        @anglelow2
    neg    ax
@anglelow2:
    mov    [yadd],ax
    mov    [mapyadd],256
    or        ax,ax
    jns    @mapyup
    mov    [mapyadd],-256
@mapyup:

    DB GS; mov    dx,[si]            {get this line's x/y map starting-pos}
    DB GS; mov    cx,[si+2]
    cmp    [angle],256
    jb        @anglelow3
    neg    cx
    neg    dx
@anglelow3:
    add    dx,[x]                    {add hero's position}
    add    cx,[y]

    mov    bx,dx                        {make a copy of our x/y pos}
    mov    ax,cx

    shl    dx,11                        {setup x/y raycasting run}
    shl    cx,11
    xor    dx,$8000
    xor    cx,$8000

    mov    ds,WORD PTR [tiles+2]
    mov    [counts],160

    shr    ax,5                        {Find first tile (size is 32x32)}
    shr    bx,5
    mov    bh,al
    mov    [mappos],bx
    DB FS; mov al,[bx+$8000]    {get ceiling tile-index from map}
    and    al,al                        {is the first one a wall?}
    js        @start_at_wall            {yes, then do wall-run instead...}
    mov    ah,al                        {no, find tile offset in tile-picture}
    and    al,7
    shr    ah,3
    shl    ax,5
    mov    [ceilingtile],ax
    DB FS; mov al,[bx]            {get floor tile-index from map}
    mov    ah,al                        {find tile offset in tile-picture}
    and    al,7
    shr    ah,3
    shl    ax,5
    mov    si,ax

{=---- This is the normal floor/ceiling paint run ----=}

@x_run1:

    mov    bx,[counts]            {is this vertical line blocked?}
    xor    al,al
    DB FS; cmp [bx+FILLED_TABLE],al
    jne    @nodraw1

    mov    bh,dh                    {get x-position of pixel}
    mov    bl,ch                    {get y-position of pixel}
    xor    bx,$8080
    shr    bx,3
    and    bx,$1F1F

    mov    al,[si+bx]            {get that pixel}
    add    al,[colouradd]
    mov    ah,al
    mov    [es:di],ax            {store ceiling pixel}
    add    bx,[ceilingtile]
    mov    al,[bx]                {get that pixel}
    add    al,[colouradd]
    mov    ah,al
    mov    bx,[flooradd]
    mov    [es:di+bx],ax        {store floor pixels}

@nodraw1:
    add    di,2
    add    dx,[xadd]            {add to x-slope}
    jo        @doxadd
    add    cx,[yadd]            {add to y-slope}
    jo        @doyadd
@1:dec    [counts]
    jnz    @x_run1
    jmp    NEAR PTR @nextline

{=---- Bumped into a new tile. Calc new address for tile ----=}

@doxadd:
    mov    bx,[mappos]
    add    bx,[mapxadd]
    mov    [mappos],bx

    add    cx,[yadd]            {add to y-slope also}
    jno    @noyadd
@doyadd:
    mov    bx,[mappos]
    add    bx,[mapyadd]
    mov    [mappos],bx
@noyadd:

    DB FS; mov al,[bx+$8000]    {get new ceiling tile-index from map}

    push    ax                            {store it so we l8r can check if it's a wall}
    and    al,127

    mov    ah,al                        {find tile offset in tile-picture}
    and    al,7
    shr    ah,3
    shl    ax,5
    mov    [ceilingtile],ax
    DB FS; mov al,[bx]            {get new floor tile-index from map}
    mov    ah,al                        {find tile offset in tile-picture}
    and    al,7
    shr    ah,3
    shl    ax,5
    mov    si,ax

    pop    ax                            {was it a wall?}
    and    al,al
    js        @2                            {yes, do wall-run}
    jmp    NEAR PTR @1                {no, do floor/ceiling run}


{=---- We have found a wall. Should handle "round" walls too ----=}

@start_at_wall:
    and    al,127
    mov    ah,al                        {find map position in map-buffer}
    and    al,7
    shr    ah,3
    shl    ax,5
    mov    [ceilingtile],ax
    DB FS; mov al,[bx]            {get floor tile-index from map}
    mov    ah,al                        {find map position in map-buffer}
    and    al,7
    shr    ah,3
    shl    ax,5
    mov    si,ax

@x_run2:

    mov    bx,[counts]            {is this vertical line blocked?}
    xor    al,al
    DB FS; cmp [bx+FILLED_TABLE],al
    jne    @nodraw2

    mov    bh,dh                    {get x-position of pixel}
    mov    bl,ch                    {get y-position of pixel}
    xor    bx,$8080
    shr    bx,3
    and    bx,$1F1F

    add    bx,[ceilingtile]
    mov    al,[bx]                {check if there is a wall right here}
    and    al,al
    jns    @drawwall            {yes, there is}
    mov    al,29                    {no, paint ceiling and floor with colour #29}
    add    al,[colouradd]
    mov    ah,al
    mov    [es:di],ax            {store ceiling pixels}
    mov    bx,[flooradd]
    mov    [es:di+bx],ax        {store floor pixels}

@nodraw2:
    add    di,2
    add    dx,[xadd]            {add to x-slope}
    jo        @doxadd
    add    cx,[yadd]            {add to y-slope}
    jo        @doyadd
@2:dec    [counts]
    jnz    @x_run2
    jmp    NEAR PTR @nextline


{=----- draw the bloody wall then ----=}

@drawwall:
    push    dx
    push    cx
    push    di
    push    si

    mov    bx,si
    add    bl,al

    mov    si,[walltablepos]
    DB FS; mov cx,[si]        {get wall height}
    DB FS; mov si,[si+2]        {get wall run-add}
    xor    dl,dl
    mov    dh,bh

@fillout_wall:
    mov    bh,dh
    mov    al,[bx]                {get that walltexture pixel}
    add    al,[colouradd]
    mov    ah,al
    mov    [es:di],ax            {store wall pixels}
    add    di,320
    add    dx,si
    dec    cx
    jnz    @fillout_wall

    pop    si
    pop    di
    pop    cx
    pop    dx
    add    di,2

    mov    bx,[counts]            {mark vertical line as blocked}
    mov    al,1
    DB FS; mov [bx+FILLED_TABLE],al

    add    dx,[xadd]            {add to x-slope}
    jo        @doxadd
    add    cx,[yadd]            {add to y-slope}
    jo        @doyadd
    dec    [counts]
    jnz    @x_run2


{=------ OK. We are ready for the next horizontal line ------=}

@nextline:
    mov    ax,SEG @DATA
    mov    ds,ax

    add    [walltablepos],4
    sub    [flooradd],320*2
    add    [tablepos],8

    mov    bx,[height]
    mov    al,[OFFSET colourtable+bx]
    mov    [colouradd],al

    dec    [height]
    jnz    @y_run

    pop    ds
end;

(*------------------------------------------------*)

procedure CopyBuffer2Screen; assembler;
asm
    push    ds
    mov    es,SEGA000
    mov    di,20*320
    lds    si,buffer
    mov    cx,(161*320)/2
    cld
    rep movsw
    pop    ds
end;


(*------------------------------------------------*)

procedure RunOnce;
begin
    while retraces=0 do ;
    retraces:=0;
{$IFDEF DEBUG}    VBLANK; SetRGB(0,20,0,0); {$ENDIF}
    CopyBuffer2Screen;
    DrawDoom(xpos,ypos, angle, CoordPtr[angle AND 255]);
    MoveHero;
{$IFDEF DEBUG}    SetRGB(0,0,0,0); {$ENDIF}
end;


begin
    if NOT MouseDriverPresent then begin writeln('No mouse...'); halt; end;

    SetScreenMode(MODE320x200x256);
    InitDemo;
    SetAllInterrupts;
    repeat RunOnce until Key='e';
    RestoreAllInterrupts;
    UninitDemo;
    SetScreenMode(TEXTMODE);
end.